home *** CD-ROM | disk | FTP | other *** search
- # -*- perl -*-
- #
- # Copyright (C) 2004-2006 Daniel P. Berrange
- #
- # This program is free software; You can redistribute it and/or modify
- # it under the same terms as Perl itself. Either:
- #
- # a) the GNU General Public License as published by the Free
- # Software Foundation; either version 2, or (at your option) any
- # later version,
- #
- # or
- #
- # b) the "Artistic License"
- #
- # The file "COPYING" distributed along with this file provides full
- # details of the terms and conditions of the two licenses.
-
- =pod
-
- =head1 NAME
-
- Net::DBus - Perl extension for the DBus message system
-
- =head1 SYNOPSIS
-
-
- ####### Attaching to the bus ###########
-
- use Net::DBus;
-
- # Find the most appropriate bus
- my $bus = Net::DBus->find;
-
- # ... or explicitly go for the session bus
- my $bus = Net::DBus->session;
-
- # .... or explicitly go for the system bus
- my $bus = Net::DBus->system
-
-
- ######## Accessing remote services #########
-
- # Get a handle to the HAL service
- my $hal = $bus->get_service("org.freedesktop.Hal");
-
- # Get the device manager
- my $manager = $hal->get_object("/org/freedesktop/Hal/Manager",
- "org.freedesktop.Hal.Manager");
-
- # List devices
- foreach my $dev (@{$manager->GetAllDevices}) {
- print $dev, "\n";
- }
-
-
- ######### Providing services ##############
-
- # Register a service known as 'org.example.Jukebox'
- my $service = $bus->export_service("org.example.Jukebox");
-
-
- =head1 DESCRIPTION
-
- Net::DBus provides a Perl API for the DBus message system.
- The DBus Perl interface is currently operating against
- the 0.32 development version of DBus, but should work with
- later versions too, providing the API changes have not been
- too drastic.
-
- Users of this package are either typically, service providers
- in which case the L<Net::DBus::Service> and L<Net::DBus::Object>
- modules are of most relevance, or are client consumers, in which
- case L<Net::DBus::RemoteService> and L<Net::DBus::RemoteObject>
- are of most relevance.
-
- =head1 METHODS
-
- =over 4
-
- =cut
-
- package Net::DBus;
-
- use 5.006;
- use strict;
- use warnings;
-
- BEGIN {
- our $VERSION = '0.33.6';
- require XSLoader;
- XSLoader::load('Net::DBus', $VERSION);
- }
-
- use Net::DBus::Binding::Bus;
- use Net::DBus::Service;
- use Net::DBus::RemoteService;
- use Net::DBus::Test::MockConnection;
- use Net::DBus::Binding::Value;
-
- use vars qw($bus_system $bus_session);
-
- use Exporter qw(import);
-
- use vars qw(@EXPORT_OK %EXPORT_TAGS);
-
- @EXPORT_OK = qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64
- dbus_byte dbus_boolean dbus_string dbus_double
- dbus_object_path dbus_signature
- dbus_struct dbus_array dbus_dict dbus_variant);
-
- %EXPORT_TAGS = (typing => [qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64
- dbus_byte dbus_boolean dbus_string dbus_double
- dbus_object_path dbus_signature
- dbus_struct dbus_array dbus_dict dbus_variant)]);
-
- =item my $bus = Net::DBus->find(%params);
-
- Search for the most appropriate bus to connect to and
- return a connection to it. The heuristic used for the
- search is
-
- - If DBUS_STARTER_BUS_TYPE is set to 'session' attach
- to the session bus
-
- - Else If DBUS_STARTER_BUS_TYPE is set to 'system' attach
- to the system bus
-
- - Else If DBUS_SESSION_BUS_ADDRESS is set attach to the
- session bus
-
- - Else attach to the system bus
-
- The optional C<params> hash can contain be used to specify
- connection options. The only support option at this time
- is C<nomainloop> which prevents the bus from being automatically
- attached to the main L<Net::DBus::Reactor> event loop.
-
- =cut
-
- sub find {
- my $class = shift;
-
- if ($ENV{DBUS_STARTER_BUS_TYPE} &&
- $ENV{DBUS_STARTER_BUS_TYPE} eq "session") {
- return $class->session(@_);
- } elsif ($ENV{DBUS_STARTER_BUS_TYPE} &&
- $ENV{DBUS_STARTER_BUS_TYPE} eq "system") {
- return $class->system(@_);
- } elsif (exists $ENV{DBUS_SESSION_BUS_ADDRESS}) {
- return $class->session(@_);
- } else {
- return $class->system;
- }
- }
-
- =item my $bus = Net::DBus->system(%params);
-
- Return a handle for the system message bus. Note that the
- system message bus is locked down by default, so unless appropriate
- access control rules are added in /etc/dbus/system.d/, an application
- may access services, but won't be able to export services.
- The optional C<params> hash can contain be used to specify
- connection options. The only support option at this time
- is C<nomainloop> which prevents the bus from being automatically
- attached to the main L<Net::DBus::Reactor> event loop.
-
- =cut
-
- sub system {
- my $class = shift;
- my %params = @_;
- if ($params{private}) {
- return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM, private => 1), @_);
- }
-
- unless ($bus_system) {
- $bus_system = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM), @_);
- }
- return $bus_system
- }
-
- =item my $bus = Net::DBus->session(%params);
-
- Return a handle for the session message bus.
- The optional C<params> hash can contain be used to specify
- connection options. The only support option at this time
- is C<nomainloop> which prevents the bus from being automatically
- attached to the main L<Net::DBus::Reactor> event loop.
-
- =cut
-
- sub session {
- my $class = shift;
- my %params = @_;
- if ($params{private}) {
- return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION, private => 1), @_);
- }
-
- unless ($bus_session) {
- $bus_session = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION), @_);
- }
- return $bus_session;
- }
-
-
- =item my $bus = Net::DBus->test(%params);
-
- Returns a handle for a virtual bus for use in unit tests. This bus does
- not make any network connections, but rather has an in-memory message
- pipeline. Consult L<Net::DBus::Test::MockConnection> for further details
- of how to use this special bus.
-
- =cut
-
- # NB. explicitly do *NOT* cache, since unit tests
- # should always have pristine state
- sub test {
- my $class = shift;
- return $class->_new(Net::DBus::Test::MockConnection->new());
- }
-
- =item my $bus = Net::DBus->new($address, %params);
-
- Return a connection to a specific message bus. The C<$address>
- parameter must contain the address of the message bus to connect
- to. An example address for a session bus might look like
- C<unix:abstract=/tmp/dbus-PBFyyuUiVb,guid=191e0a43c3efc222e0818be556d67500>,
- while one for a system bus would look like C<unix:/var/run/dbus/system_bus_socket>.
- The optional C<params> hash can contain be used to specify
- connection options. The only support option at this time
- is C<nomainloop> which prevents the bus from being automatically
- attached to the main L<Net::DBus::Reactor> event loop.
-
- =cut
-
- sub new {
- my $class = shift;
- my $nomainloop = shift;
- return $class->_new(Net::DBus::Binding::Bus->new(address => shift), @_);
- }
-
- sub _new {
- my $class = shift;
- my $self = {};
-
- $self->{connection} = shift;
- $self->{signals} = [];
- $self->{services} = {};
-
- my %params = @_;
-
- bless $self, $class;
-
- unless ($params{nomainloop}) {
- if (exists $INC{'Net/DBus/Reactor.pm'}) {
- my $reactor = $params{reactor} ? $params{reactor} : Net::DBus::Reactor->main;
- $reactor->manage($self->get_connection);
- }
- # ... Add support for GLib and POE
- }
-
- $self->get_connection->add_filter(sub { return $self->_signal_func(@_); });
-
- $self->{bus} = Net::DBus::RemoteService->new($self, "org.freedesktop.DBus", "org.freedesktop.DBus");
-
- return $self;
- }
-
- =item my $connection = $bus->get_connection;
-
- Return a handle to the underlying, low level connection object
- associated with this bus. The returned object will be an instance
- of the L<Net::DBus::Binding::Bus> class. This method is not intended
- for use by (most!) application developers, so if you don't understand
- what this is for, then you don't need to be calling it!
-
- =cut
-
- sub get_connection {
- my $self = shift;
- return $self->{connection};
- }
-
- =item my $service = $bus->get_service($name);
-
- Retrieves a handle for the remote service identified by the
- service name C<$name>. The returned object will be an instance
- of the L<Net::DBus::RemoteService> class.
-
- =cut
-
- sub get_service {
- my $self = shift;
- my $name = shift;
-
- if ($name eq "org.freedesktop.DBus") {
- return $self->{bus};
- }
-
- my $owner = $name;
- if ($owner !~ /^:/) {
- $owner = $self->get_service_owner($name);
- if (!$owner) {
- $self->get_bus_object->StartServiceByName($name, 0);
- $owner = $self->get_service_owner($name);
- }
- }
-
- unless (exists $self->{services}->{$owner}) {
- $self->{services}->{$owner} = Net::DBus::RemoteService->new($self, $owner, $name);
- }
- return $self->{services}->{$owner};
- }
-
- =item my $service = $bus->export_service($name);
-
- Registers a service with the bus, returning a handle to
- the service. The returned object is an instance of the
- L<Net::DBus::Service> class.
-
- =cut
-
- sub export_service {
- my $self = shift;
- my $name = shift;
- return Net::DBus::Service->new($self, $name);
- }
-
- =item my $object = $bus->get_bus_object;
-
- Retrieves a handle to the bus object, C</org/freedesktop/DBus>,
- provided by the service C<org.freedesktop.DBus>. The returned
- object is an instance of L<Net::DBus::RemoteObject>
-
- =cut
-
- sub get_bus_object {
- my $self = shift;
-
- my $service = $self->get_service("org.freedesktop.DBus");
- return $service->get_object('/org/freedesktop/DBus',
- 'org.freedesktop.DBus');
- }
-
-
- =item my $name = $bus->get_unique_name;
-
- Retrieves the unique name of this client's connection to
- the bus.
-
- =cut
-
- sub get_unique_name {
- my $self = shift;
-
- return $self->get_connection->get_unique_name
- }
-
- =item my $name = $bus->get_service_owner($service);
-
- Retrieves the unique name of the client on the bus owning
- the service named by the C<$service> parameter.
-
- =cut
-
- sub get_service_owner {
- my $self = shift;
- my $service = shift;
-
- my $bus = $self->get_bus_object;
- my $owner = eval {
- $bus->GetNameOwner($service);
- };
- if ($@) {
- if (UNIVERSAL::isa($@, "Net::DBus::Error") &&
- $@->{name} eq "org.freedesktop.DBus.Error.NameHasNoOwner") {
- $owner = undef;
- } else {
- die $@;
- }
- }
- return $owner;
- }
-
-
- sub _add_signal_receiver {
- my $self = shift;
- my $receiver = shift;
- my $signal_name = shift;
- my $interface = shift;
- my $service = shift;
- my $path = shift;
-
- my $rule = $self->_match_rule($signal_name, $interface, $service, $path);
-
- push @{$self->{signals}}, [$receiver, $rule, $signal_name, $interface, $service, $path];
- $self->{connection}->add_match($rule);
- }
-
- sub _remove_signal_receiver {
- my $self = shift;
- my $receiver = shift;
- my $signal_name = shift;
- my $interface = shift;
- my $service = shift;
- my $path = shift;
-
- my $rule = $self->_match_rule($signal_name, $interface, $service, $path);
-
- my @signals;
- foreach (@{$self->{signals}}) {
- if ($_->[0] eq $receiver &&
- defined $_->[1] &&
- $_->[1] eq $rule) {
- $self->{connection}->remove_match($rule);
- } else {
- push @signals, $_;
- }
- }
- $self->{signals} = \@signals;
- }
-
-
- sub _match_rule {
- my $self = shift;
- my $signal_name = shift;
- my $interface = shift;
- my $service = shift;
- my $path = shift;
-
- my $rule = "type='signal'";
- if ($interface) {
- $rule .= ",interface='$interface'";
- }
- if ($service) {
- if ($service !~ /^:/) {
- # Resolve service name to a client id
- $service = $self->get_service_owner($service);
- }
- if ($service) {
- $rule .= ",sender='$service'";
- }
- }
- if ($path) {
- $rule .= ",path='$path'";
- }
- if ($signal_name) {
- $rule .= ",member='$signal_name'";
- }
- return $rule;
- }
-
-
- sub _rule_matches {
- my $self = shift;
- my $rule = shift;
- my $member = shift;
- my $interface = shift;
- my $sender = shift;
- my $path = shift;
-
- my %bits;
- map {
- if (/^(\w+)='(.*)'$/) {
- $bits{$1} = $2;
- }
- } split /,/, $rule;
-
-
- if (exists $bits{member} &&
- $bits{member} ne $member) {
- return 0;
- }
- if (exists $bits{interface} &&
- $bits{interface} ne $interface) {
- return 0;
- }
- if (exists $bits{sender} &&
- $bits{sender} ne $sender) {
- return 0;
- }
- if (exists $bits{path} &&
- $bits{path} ne $path) {
- return 0;
- }
- return 1;
- }
-
- sub _signal_func {
- my $self = shift;
- my $connection = shift;
- my $message = shift;
-
- return 0 unless $message->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL;
-
- my $interface = $message->get_interface;
- my $sender = $message->get_sender;
- my $path = $message->get_path;
- my $member = $message->get_member;
-
- my $handled = 0;
- foreach my $handler (grep { defined $_->[1] &&
- $self->_rule_matches($_->[1], $member, $interface, $sender, $path) }
- @{$self->{signals}}) {
- my $callback = $handler->[0];
- &$callback($message);
- $handled = 1;
- }
-
- return $handled;
- }
-
- =back
-
- =head1 DATA TYPING METHODS
-
- These methods are not usually used, since most services provide introspection
- data to inform clients of their data typing requirements. If introspection data
- is incomplete, however, it may be neccessary for a client to mark values with
- specific data types. In such a case, the following methods can be used. They
- are not, however, exported by default so must be requested at import time by
- specifying 'use Net::DBus qw(:typing)'
-
- =over 4
-
- =item $typed_value = dbus_int16($value);
-
- Mark a value as being a signed, 16-bit integer.
-
- =cut
-
- sub dbus_int16 {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT16,
- $_[0]);
-
- }
-
- =item $typed_value = dbus_uint16($value);
-
- Mark a value as being an unsigned, 16-bit integer.
-
- =cut
-
-
- sub dbus_uint16 {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT16,
- $_[0]);
- }
-
- =item $typed_value = dbus_int32($value);
-
- Mark a value as being a signed, 32-bit integer.
-
- =cut
-
- sub dbus_int32 {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT32,
- $_[0]);
-
- }
-
- =item $typed_value = dbus_uint32($value);
-
- Mark a value as being an unsigned, 32-bit integer.
-
- =cut
-
-
- sub dbus_uint32 {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT32,
- $_[0]);
- }
-
- =item $typed_value = dbus_int64($value);
-
- Mark a value as being an unsigned, 64-bit integer.
-
- =cut
-
-
-
- sub dbus_int64 {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT64,
- $_[0]);
-
- }
-
- =item $typed_value = dbus_uint64($value);
-
- Mark a value as being an unsigned, 64-bit integer.
-
- =cut
-
-
-
- sub dbus_uint64 {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT64,
- $_[0]);
- }
-
- =item $typed_value = dbus_double($value);
-
- Mark a value as being a double precision IEEE floating point.
-
- =cut
-
-
-
- sub dbus_double {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_DOUBLE,
- $_[0]);
- }
-
- =item $typed_value = dbus_byte($value);
-
- Mark a value as being an unsigned, byte.
-
- =cut
-
-
-
- sub dbus_byte {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BYTE,
- $_[0]);
- }
-
- =item $typed_value = dbus_string($value);
-
- Mark a value as being a UTF-8 string. This is not usually required
- since 'string' is the default data type for any Perl scalar value.
-
- =cut
-
-
-
- sub dbus_string {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRING,
- $_[0]);
- }
-
- =item $typed_value = dbus_signature($value);
-
- Mark a value as being a UTF-8 string, whose contents is a valid
- type signature
-
- =cut
-
-
-
- sub dbus_signature {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_SIGNATURE,
- $_[0]);
- }
-
- =item $typed_value = dbus_object_path($value);
-
- Mark a value as being a UTF-8 string, whose contents is a valid
- object path.
-
- =cut
-
- sub dbus_object_path {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
- $_[0]);
- }
-
- =item $typed_value = dbus_boolean($value);
-
- Mark a value as being an boolean
-
- =cut
-
-
-
- sub dbus_boolean {
- return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BOOLEAN,
- $_[0]);
- }
-
- =item $typed_value = dbus_array($value);
-
- Mark a value as being an array
-
- =cut
-
-
- sub dbus_array {
- return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_ARRAY],
- $_[0]);
- }
-
- =item $typed_value = dbus_struct($value);
-
- Mark a value as being a structure
-
- =cut
-
-
- sub dbus_struct {
- return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_STRUCT],
- $_[0]);
- }
-
- =item $typed_value = dbus_dict($value);
-
- Mark a value as being a dictionary
-
- =cut
-
- sub dbus_dict{
- return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_DICT_ENTRY],
- $_[0]);
- }
-
- =item $typed_value = dbus_variant($value);
-
- Mark a value as being a variant
-
- =cut
-
- sub dbus_variant{
- return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_VARIANT],
- $_[0]);
- }
-
- =pod
-
- =back
-
- =head1 SEE ALSO
-
- L<Net::DBus>, L<Net::DBus::RemoteService>, L<Net::DBus::Service>,
- L<Net::DBus::RemoteObject>, L<Net::DBus::Object>,
- L<Net::DBus::Exporter>, L<Net::DBus::Dumper>, L<Net::DBus::Reactor>,
- C<dbus-monitor(1)>, C<dbus-daemon-1(1)>, C<dbus-send(1)>, L<http://dbus.freedesktop.org>,
-
- =head1 AUTHOR
-
- Daniel Berrange <dan@berrange.com>
-
- =head1 COPYRIGHT
-
- Copyright 2004-2005 by Daniel Berrange
-
- =cut
-
- 1;
-